***                                                                                                                                                                                                                                                       
***                                                                                                                                                                                                                                                       
*** This Program already converted to Y2K                                                                                                                                                                                                                 
*** S&T Departement     on 29 April 1999 by Ben.Rahman                                                                                                                                                                                                    
***                                                                                                                                                                                                                                                       
*** ------------------------------------------------------------------------
*** change request#1: Include the magnetic swipe card options
***
*** ------------------------------------------------------------------------
*** change request#7: Include the LCARDLOG.DBF for usage history tracking 
***
*** ------------------------------------------------------------------------

set cent on
SET COLO TO BG+/B,W+/N                                                                                                                                                                                                                                    
CLEAR                                                                                                                                                                                                                                                     
SET PROC TO SOSPRO                                                                                                                                                                                                                                        
SET PROC TO BOXPROC                                                                                                                                                                                                                                       
set proc to addrepro                                                                                                                                                                                                                                     
                                                                                                                                                                                                                                                          
STORE ' ' TO AEANAME,AEAADDR,AEACITY,AEACOUN,AEACURR                                                                                                                                                                                                      
STORE .F. TO AEAHEAL,AEADECI                                                                                                                                                                                                                              



DO START                                                                                                                                                                                                                                                  
DR='n:'                                                                                                                                                                                                                                                   
F1='PATIENT'                                                                                                                                                                                                                                              
F11='NAME'                                                                                                                                                                                                                                                
F12='FNAME'                                                                                                                                                                                                                                               
F13='PATCOD'                                                                                                                                                                                                                                              
F3='IN_PAT'                                                                                                                                                                                                                                               
F2='COMPANY'                                                                                                                                                                                                                                              
F21='NMCOMP'                                                                                                                                                                                                                                              
F5='PATJAPAN'                                                                                                                                                                                                                                             

** chq req#6 to include the locacard.dbf table to retrieve the comp_nam & pat_filcod for each center
F6='LOCACARD'
STORE SPACE(6) TO FIELD_PATFIL
**
** chg req#7 to include one more table - lcardlog.dbf to log the swipe card usage history - requested by RW
F7='LCARDLOG'
**

select 7
set exclu off
use &dr&f7

sele 2
set exclu off                                                                                                                                                                                                                                             
use &dr&f2                                                                                                                                                                                                                                                
set index to &dr&f2                                                                                                                                                                                                                                       
                                                                                                                                                                                                                                                          
SELE 1                                                                                                                                                                                                                                                    
SET EXCLU OFF                                                                                                                                                                                                                                             
USE &DR&F1 INDE &DR&F1,&DR&F11,&DR&F12                                                                                                                                                                                                                    
STORE 0 TO PIL1                                                                                                                                                                                                                                           
                                                                                                                                                                                                                                                          
                                                                                                                                                                                                                                                          
DO WHILE PIL1=0                                                                                                                                                                                                                                           
   STORE 0 TO PIL2,PIL3,PIL4,PIL5,PIL6,PIL7,PIL8,REC                                                                                                                                                                                                      
   STORE .F. TO TRUEPAT,PRPAT,PATIN,CMS                                                                                                                                                                                                                   
   store space(10) to nmdoct                                                                                                                                                                                                                              
   store space(3) to doct                                                                                                                                                                                                                                 
   store space(10) to patnat                                                                                                                                                                                                                              
   insval=ctod("  /  /    ")                                                                                                                                                                                                                              
   do addresss                                                                                                                                                                                                                                            
   SET COLO TO BG+/B,W+/N                                                                                                                                                                                                                                 
   @ 4,1 CLEAR TO 6,50                                                                                                                                                                                                                                    
   DO ADDRTITL WITH "TO RETRIEVE A PATIENT'S FILE"

   ** chg req#1
   DO BOX2 WITH 12,3,"IS THE PATIENT ? :","ALREADY REGISTERED","A NEW PATIENT",'GR+','RB','GR+','R',PIL1,.F.,.T.                                                                                                                                          
   DO CASE                                                                                                                                                                                                                                                
      CASE LASTKEY()=27                                                                                                                                                                                                                                   
         RETURN                                                                                                                                                                                                                                           
      CASE PIL1=2                                                                                                                                                                                                                                         
         PATRV=.T.
         close index                                                                                                                                                                                                                                      
         DO PREG1                                                                                                                                                                                                                                         
         DO PATR17                                                                                                                                                                                                                                        
      CASE PIL1=1


         DO PATR2                                                                                                                                                                                                                                         
   ENDCASE                                                                                                                                                                                                                                                
   if PRPAT                                                                                                                                                                                                                                               
      pil1=0                                                                                                                                                                                                                                              
   endif                                                                                                                                                                                                                                                  
ENDDO                                                                                                                                                                                                                                                     
RETURN                                                                                                                                                                                                                                                    
